home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / language / ici / ici.cpi / object.c < prev    next >
C/C++ Source or Header  |  1994-10-27  |  12KB  |  572 lines
  1. #include "exec.h"
  2. #include "buf.h"
  3. #include "int.h"
  4. #include "str.h"
  5. #include "float.h"
  6. #include "func.h"
  7.  
  8. #ifdef MULTI
  9. #include    "multi.h"
  10. #endif
  11.  
  12. #define    VERBOSE    0
  13.  
  14. /*
  15.  * The global error message pointer.
  16.  */
  17. char        *error;
  18.  
  19. /*
  20.  * All objects are either on the objects list on in the atom pool.
  21.  */
  22. object_t    **objs;        /* List of all objects. */
  23. object_t    **objs_limit;    /* First element we can't use in list. */
  24. object_t    **objs_top;    /* Next unused element in list. */
  25.  
  26. object_t    **atoms;    /* Hash table of lists of atomic objects. */
  27. int        atomsz;        /* Number of slots in hash table. */
  28. STATIC int    natoms;        /* Number of atomic objects. */
  29.  
  30. /*
  31.  * Some primes just less than powers of two. We use these for
  32.  * successive sizes of the atom pool (a hash table).
  33.  */
  34. static int        atomzi;        /* Current index into... */
  35. static unsigned long    atomzs[] =
  36. {
  37.     61,    127,    251,    509,    1021,
  38.     2039,    4093,    8191,    16381,    32749,
  39.     65521,    131071,    262139,    524287,    1048573,
  40.     (2<<21)-1,(2<<22)-1,(2<<23)-1,(2<<24)-1,(2<<25)-1,
  41.     (2<<26)-1,(2<<27)-1,(2<<28)-1,(2<<29)-1,(2<<30)-1,
  42.     (2<<31)-1
  43. };
  44.  
  45. /*
  46.  * Format a human readable version of the object in 30 chars or less.
  47.  */
  48. char *
  49. objname(p, o)
  50. register char        *p;
  51. register object_t    *o;
  52. {
  53.     extern char    *strchr();
  54.  
  55.     if (isstring(o))
  56.     {
  57.     if (stringof(o)->s_nchars > 10)
  58.         sprintf(p, "\"%.10s...\"", stringof(o)->s_chars);
  59.     else
  60.         sprintf(p, "\"%s\"", stringof(o)->s_chars);
  61.     }
  62.     else if (isint(o))
  63.     sprintf(p, "%ld", intof(o)->i_value);
  64.     else if (isfloat(o))
  65.     sprintf(p, "%g", floatof(o)->f_value);
  66.     else if (isfunc(o) && (o->o_flags & O_CFUNC) && funcof(o)->f_name != NULL)
  67.     sprintf(p, "%s()", funcof(o)->f_name->s_chars);
  68.     else if (isfunc(o) && !(o->o_flags & O_CFUNC) && cfuncof(o)->cf_name !=NULL)
  69.     sprintf(p, "%s()", cfuncof(o)->cf_name);
  70.     else if (strchr("aeiou", o->o_type->t_name[0]) != NULL)
  71.     sprintf(p, "an %s", o->o_type->t_name);
  72.     else
  73.     sprintf(p, "a %s", o->o_type->t_name);
  74.     return p;
  75. }
  76.  
  77. void
  78. free_simple(o)
  79. register object_t    *o;
  80. {
  81.     zfree((char *)o);
  82. }
  83.  
  84. object_t *
  85. copy_simple(o)
  86. object_t    *o;
  87. {
  88.     return o;
  89. }
  90.  
  91. int
  92. assign_simple(o, k, v)
  93. object_t    *o;
  94. object_t    *k;
  95. object_t    *v;
  96. {
  97.     char    n1[30];
  98.     char    n2[30];
  99.     char    n3[30];
  100.  
  101.     sprintf(buf, "attempt to set %s keyed by %s to %s",
  102.     objname(n1, o),
  103.     objname(n2, k),
  104.     objname(n3, v));
  105.     error = buf;
  106.     return 1;
  107. }
  108.  
  109. object_t *
  110. fetch_simple(o, k)
  111. object_t    *o;
  112. object_t    *k;
  113. {
  114.     char    n1[30];
  115.     char    n2[30];
  116.  
  117.     sprintf(buf, "attempt to read %s keyed by %s",
  118.     objname(n1, o),
  119.     objname(n2, k));
  120.     error = buf;
  121.     return NULL;
  122. }
  123.  
  124. /*
  125.  * For objects which can't be copied and are intrinsically unique.
  126.  */
  127. int
  128. cmp_unique(o1, o2)
  129. object_t    *o1;
  130. object_t    *o2;
  131. {
  132.     return o1 != o2;
  133. }
  134.  
  135. long
  136. hash_unique(o)
  137. object_t    *o;
  138. {
  139.     return (long)o;
  140. }
  141.  
  142. /*
  143.  * Grow the hash table of atoms to be four times as big, plus three.
  144.  */
  145. STATIC void
  146. grow_atoms()
  147. {
  148.     register object_t    **o;
  149.     register int    i;
  150.     object_t        **olda;
  151.     int            newz;
  152.  
  153.     newz = atomzs[atomzi + 1];
  154.     if ((o = (object_t **)zalloc(newz * sizeof(object_t *))) == NULL)
  155.     return;
  156.     ++atomzi;
  157.     i = atomsz;
  158.     atomsz = newz;
  159.     memset((char *)o, 0, newz * sizeof(object_t *));
  160.     natoms = 0;
  161.     olda = atoms;
  162.     atoms = o;
  163.     while (--i >= 0)
  164.     {
  165.     if (olda[i] != NULL)
  166.     {
  167.         olda[i]->o_flags &= ~O_ATOM;
  168.         atom(olda[i], 1);
  169.     }
  170.     }
  171.     zfree((char *)olda);
  172. }
  173.  
  174. /*
  175.  * Return an object equal to the one given, but possibly shared by others.
  176.  * Never fails, at worst it just returns its argument.  If the lone flag
  177.  * is given, the object is free'd if it isn't used.  ("lone" because the
  178.  * caller has the lone reference to it and will replace that with what
  179.  * atom returns anyway.)  If the lone flag is not given, and the object
  180.  * would be used, a copy will be used.  Also note that if the given and
  181.  * the object is not used, the refs of the passed object will be transfered
  182.  * to the object being returned.
  183.  */
  184. object_t *
  185. atom(o, lone)
  186. register object_t    *o;
  187. int            lone;
  188. {
  189.     register object_t    **po;
  190.  
  191.     if (o->o_flags & O_ATOM)
  192.     return o;
  193.     for
  194.     (
  195.     po = &atoms[((unsigned long)o->o_type + hash(o)) % atomsz];
  196.     *po != NULL;
  197.     --po < atoms ? po = atoms + atomsz - 1 : NULL
  198.     )
  199.     {
  200.     if (o->o_type == (*po)->o_type && cmp(o, *po) == 0)
  201.     {
  202.         if (lone)
  203.         {
  204.         (*po)->o_nrefs += o->o_nrefs;
  205.         o->o_nrefs = 0;
  206.         }
  207.         return *po;
  208.     }
  209.     }
  210.  
  211.     /*
  212.      * Not found.  Add this object (or a copy of it) to the atom pool.
  213.      */
  214.     if (!lone)
  215.     {
  216.     if ((*po = copy(o)) == NULL)
  217.         return o;
  218.     o = *po;
  219.     }
  220.     *po = o;
  221.     o->o_flags |= O_ATOM;
  222.     if (++natoms > atomsz / 2)
  223.     grow_atoms();
  224.     if (!lone)
  225.     loose(o);
  226.     return o;
  227. }
  228.  
  229. /*
  230.  * Probe the atom pool for an atomic form of o.  If found, return that
  231.  * atomic form, else NULL.  Used by various new_*() routines.  These
  232.  * routines generally set up a dummy version of the object being made
  233.  * which is passed to this probe.  If it finds a match, that is returned,
  234.  * thus avoiding the allocation of an object will may be thrown away anyway.
  235.  */
  236. object_t *
  237. atom_probe(o)
  238. register object_t    *o;
  239. {
  240.     register object_t    **po;
  241.  
  242.     for
  243.     (
  244.     po = &atoms[((unsigned long)o->o_type + hash(o)) % atomsz];
  245.     *po != NULL;
  246.     --po < atoms ? po = atoms + atomsz - 1 : NULL
  247.     )
  248.     {
  249.     if (o->o_type == (*po)->o_type && cmp(o, *po) == 0)
  250.         return *po;
  251.     }
  252.     return NULL;
  253. }
  254.  
  255. /*
  256.  * Quick search for an int to save allocation/deallocation if it already
  257.  * exists.
  258.  */
  259. int_t *
  260. atom_int(i)
  261. register long    i;
  262. {
  263.     register object_t    *o;
  264.     register object_t    **po;
  265.  
  266.     /*
  267.      * NB: There is an in-line version of this code in binop.h
  268.      */
  269.     for
  270.     (
  271.     po = &atoms[((unsigned long)&int_type + i * 7) % atomsz];
  272.     (o = *po) != NULL;
  273.     --po < atoms ? po = atoms + atomsz - 1 : NULL
  274.     )
  275.     {
  276.     if (isint(o) && intof(o)->i_value == i)
  277.         return intof(o);
  278.     }
  279.     return NULL;
  280. }
  281.  
  282. STATIC void
  283. unatom(o)
  284. object_t    *o;
  285. {
  286.     register object_t    **sl;
  287.     register object_t    **ss;
  288.     register object_t    **ws;    /* Wanted position. */
  289.  
  290.     for
  291.     (
  292.     ss = &atoms[((unsigned long)o->o_type + hash(o)) % atomsz];
  293.     *ss != NULL;
  294.     --ss < atoms ? ss = atoms + atomsz - 1 : NULL
  295.     )
  296.     {
  297.     if (o == *ss)
  298.        goto delete;
  299.     }
  300.     /*printf("Warning: could not find atom being deleted\n");*/
  301.     return;
  302.  
  303. delete:
  304.     o->o_flags &= ~O_ATOM;
  305.     --natoms;
  306.     sl = ss;
  307.     /*
  308.      * Scan "forward" bubbling up entries which would rather be at our
  309.      * current empty slot.
  310.      */
  311.     for (;;)
  312.     {
  313.     if (--sl < atoms)
  314.         sl = atoms + atomsz - 1;
  315.     if (*sl == NULL)
  316.         break;
  317.     ws = &atoms[((unsigned long)(*sl)->o_type + hash(*sl)) % atomsz];
  318.     if
  319.     (
  320.         (sl < ss && (ws >= ss || ws < sl))
  321.         ||
  322.         (sl > ss && (ws >= ss && ws < sl))
  323.     )
  324.     {
  325.         /*
  326.          * The value at sl, which really wants to be at ws, should go
  327.          * into the current empty slot (ss).  Copy it to there and update
  328.          * ss to be here (which now becomes empty).
  329.          */
  330.         *ss = *sl;
  331.         ss = sl;
  332.     }
  333.     }
  334.     *ss = NULL;
  335. }
  336.  
  337. object_t *
  338. grow_objs(o)
  339. object_t    *o;
  340. {
  341.     register object_t    **newobjs;
  342.     register int    newz;
  343.  
  344.     newz = 2 * (objs_limit - objs) + 1;
  345.     if ((newobjs = (object_t **)zalloc(newz * sizeof(object_t *))) == NULL)
  346.     return o;
  347.     memcpy((char *)newobjs, (char *)objs, (char *)objs_limit - (char *)objs);
  348.     objs_limit = newobjs + newz;
  349.     objs_top = newobjs + (objs_top - objs);
  350.     memset((char *)objs_top, 0, (char *)objs_limit - (char *)objs_top);
  351.     zfree((char *)objs);
  352.     objs = newobjs;
  353.     *objs_top++ = o;
  354.     return o;
  355. }
  356.  
  357. /*
  358.  * Mark sweep garbage collection.  Should be safe to do any time, as new
  359.  * objects are created without the nrefs == 0 which allows them to be
  360.  * collected.  They must be explicitly lost before they are subject
  361.  * to garbage collection.  But of course all code must be careful not
  362.  * to hang on to "found" objects where they are not accessible, or they
  363.  * will be collected.  You can got() them if you want.  All "held" objects
  364.  * will cause all objects referenced from them to be marked (ie, not
  365.  * collected), as long as they are registered on either the global object
  366.  * list or in the atom pool.  Thus statically declared objects which
  367.  * reference other objects (very rare) must be appropriately registered.
  368.  */
  369. void
  370. collect()
  371. {
  372.     register object_t    **a;
  373.     register object_t    *o;
  374.     register object_t    **b;
  375.     register int    ndead_atoms;
  376.     register long    mem;    /* Total mem tied up in refed objects. */
  377.  
  378.     /*
  379.      * Mark all objects which are referenced (and thus what they ref).
  380.      */
  381.  
  382.     mem = 0;
  383. #ifdef MULTI
  384.     {
  385.     register proc_vars_t    *pv;
  386.  
  387.     for (pv = main_vars; pv; pv = pv->v_next)
  388.     {
  389.         objof(&pv->pv_ex.x_xs)->o_flags &= ~O_MARK;
  390.         objof(&pv->pv_ex.x_os)->o_flags &= ~O_MARK;
  391.         objof(&pv->pv_ex.x_vs)->o_flags &= ~O_MARK;
  392.         mem += mark(&pv->pv_ex.x_xs);
  393.         mem += mark(&pv->pv_ex.x_os);
  394.         mem += mark(&pv->pv_ex.x_vs);
  395.     }
  396.     }
  397. #endif
  398.  
  399.     for (a = objs; a < objs_top; ++a)
  400.     {
  401.     if ((*a)->o_nrefs != 0)
  402.         mem += mark((*a));
  403.     }
  404.  
  405.     /*
  406.      * Count how many atoms are going to be retained and how many are
  407.      * going to be lost so we can decide on the fastest method.
  408.      */
  409.     ndead_atoms = 0;
  410.     for (a = objs; a < objs_top; ++a)
  411.     {
  412.     if (((*a)->o_flags & (O_ATOM|O_MARK)) == O_ATOM)
  413.         ++ndead_atoms;
  414.     }
  415.  
  416.     /*
  417.      * Collection phase.  Discard unmarked objects, compact down marked
  418.      * objects and fix up the atom pool.
  419.      *
  420.      * Deleteing an atom from the atom pool is (say) once as expensive
  421.      * as adding one.  Use this to determine which is quicker; rebuilding
  422.      * the atom pool or deleting dead ones.
  423.      */
  424.     if (1 * ndead_atoms > (natoms - ndead_atoms))
  425.     {
  426.     /*
  427.      * Rebuilding the atom pool is a better idea.
  428.      */
  429.     memset((char *)atoms, 0, atomsz * sizeof(object_t *));
  430.     natoms = 0;
  431.     b = objs;
  432.     for (a = objs; a < objs_top; ++a)
  433.     {
  434.         if (((o = *a)->o_flags & O_MARK) == 0)
  435.         freeo(o);
  436.         else
  437.         {
  438.         o->o_flags &= ~O_MARK;
  439.         *b++ = o;
  440.         if (o->o_flags & O_ATOM)
  441.         {
  442.             o->o_flags &= ~O_ATOM;
  443.             atom(o, 1);
  444.         }
  445.         }
  446.     }
  447.     objs_top = b;
  448.     }
  449.     else
  450.     {
  451.     /*
  452.      * Faster to delete dead atoms as we go.
  453.      */
  454.     b = objs;
  455.     for (a = objs; a < objs_top; ++a)
  456.     {
  457.         if (((o = *a)->o_flags & O_MARK) == 0)
  458.         {
  459.         if (o->o_flags & O_ATOM)
  460.             unatom(o);
  461.         freeo(o);
  462.         }
  463.         else
  464.         {
  465.         o->o_flags &= ~O_MARK;
  466.         *b++ = o;
  467.         }
  468.     }
  469.     objs_top = b;
  470.     }
  471.  
  472. /*printf("mem %ld objects %d got %d atoms %d\n", mem, objs_top - objs, ngot, natoms);*/
  473.  
  474.     /*
  475.      * The amount of memory tied up in referenced objects after a collect
  476.      * helps control the pace of garbage collection.  We keep a nominal
  477.      * minimum value to stop collection when we aren't using much memory.
  478.      */
  479.     if (mem < 2048)
  480.     ici_old_mem = 2048;
  481.     else
  482.     ici_old_mem = mem;
  483.     ici_new_mem = 0;
  484. }
  485.  
  486. #ifdef    BUGHUNT
  487. got(o)
  488. {
  489.     if (++objof(o)->o_nrefs > 10)
  490.     {
  491.     printf("Warning: nrefs > 10\n");
  492.     fflush(stdout);
  493.     }
  494. }
  495.  
  496. loose(o)
  497. {
  498.     if (--objof(o)->o_nrefs < 0)
  499.     {
  500.     printf("Warning: nrefs < 0\n");
  501.     fflush(stdout);
  502.     }
  503. }
  504. #endif
  505.  
  506. #ifdef    SMALL
  507. long
  508. mark(o)
  509. object_t    *o;
  510. {
  511.     if (o->o_flags & O_MARK)
  512.     return 0L;
  513.     return (*o->o_type->t_mark)(o);
  514. }
  515.  
  516. void
  517. freeo(o)
  518. object_t    *o;
  519. {
  520.     (*o->o_type->t_free)(o);
  521. }
  522.  
  523. long
  524. hash(o)
  525. object_t    *o;
  526. {
  527.     return (*o->o_type->t_hash)(o);
  528. }
  529.  
  530. int
  531. cmp(o1, o2)
  532. object_t    *o1;
  533. object_t    *o2;
  534. {
  535.     return (*o1->o_type->t_cmp)(o1, o2);
  536. }
  537.  
  538. object_t *
  539. copy(o)
  540. object_t    *o;
  541. {
  542.     return (*o->o_type->t_copy)(o);
  543. }
  544.  
  545. object_t *
  546. fetch(o, k)
  547. object_t    *o;
  548. object_t    *k;
  549. {
  550.     return (*o->o_type->t_fetch)(o, k);
  551. }
  552.  
  553. int
  554. assign(o, k, v)
  555. object_t    *o;
  556. object_t    *k;
  557. object_t    *v;
  558. {
  559.     return (*o->o_type->t_assign)(o, k, v);
  560. }
  561.  
  562. void
  563. rego(o)
  564. object_t    *o;
  565. {
  566.     if (objs_top < objs_limit)
  567.     *objs_top++ = o;
  568.     else
  569.     grow_objs(o);
  570. }
  571. #endif
  572.